home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Source Code / C / Applications / Moscow ML 1.31 / source code / mosml / src / compiler / Ovlres.sml < prev    next >
Encoding:
Text File  |  1996-07-03  |  7.6 KB  |  234 lines  |  [TEXT/R*ch]
  1.  
  2. open List;
  3. open Fnlib Mixture Const Prim Smlprim Globals Location;
  4. open Units Types Asynt;
  5.  
  6. fun errorOverloadingType loc id tau =
  7. (
  8.   msgIBlock 0;
  9.   errLocation loc;
  10.   errPrompt "Overloaded "; msgString id;
  11.   msgString " cannot be applied to argument(s) of type ";
  12.   printType tau; msgEOL();
  13.   msgEBlock();
  14.   raise Toplevel
  15. );
  16.  
  17. val negInt = mkPrimInfo 1 (MLPprim(1, Psmlnegint))
  18. and absInt = mkPrimInfo 1 (MLPccall(1, "sml_abs_int"))
  19. and makestringInt = mkPrimInfo 1 (MLPccall(1, "sml_string_of_int"))
  20. and addInt = mkPrimInfo 1 MLPadd_int
  21. and subInt = mkPrimInfo 1 MLPsub_int
  22. and mulInt = mkPrimInfo 1 MLPmul_int
  23. and ltInt = mkPrimInfo 1 MLPlt_int
  24. and gtInt = mkPrimInfo 1 MLPgt_int
  25. and leInt = mkPrimInfo 1 MLPle_int
  26. and geInt = mkPrimInfo 1 MLPge_int
  27. ;
  28.  
  29. fun resolveIntOvlId loc "~"    OVL1NNo  = negInt
  30.   | resolveIntOvlId loc "abs"  OVL1NNo  = absInt
  31.   | resolveIntOvlId loc "makestring" OVL1NSo  = makestringInt
  32.   | resolveIntOvlId loc "+"    OVL2NNNo = addInt
  33.   | resolveIntOvlId loc "-"    OVL2NNNo = subInt
  34.   | resolveIntOvlId loc "*"    OVL2NNNo = mulInt
  35.   | resolveIntOvlId loc "<"    OVL2NNBo = ltInt
  36.   | resolveIntOvlId loc ">"    OVL2NNBo = gtInt
  37.   | resolveIntOvlId loc "<="   OVL2NNBo = leInt
  38.   | resolveIntOvlId loc ">="   OVL2NNBo = geInt
  39.   | resolveIntOvlId loc _ _ = fatalError "resolveIntOvlId"
  40. ;
  41.  
  42. val makestringChar = mkPrimInfo 1 (MLPccall(1, "sml_makestring_of_char"));
  43.  
  44. fun resolveCharOvlId loc "makestring" OVL1NSo = makestringChar
  45.   | resolveCharOvlId loc "<"    OVL2NNBo = ltInt
  46.   | resolveCharOvlId loc ">"    OVL2NNBo = gtInt
  47.   | resolveCharOvlId loc "<="   OVL2NNBo = leInt
  48.   | resolveCharOvlId loc ">="   OVL2NNBo = geInt
  49.   | resolveCharOvlId loc id     _ =
  50.       errorOverloadingType loc id type_char
  51. ;
  52.  
  53. val negReal = mkPrimInfo 1 (MLPprim(1, Pfloatprim Psmlnegfloat))
  54. and absReal = mkPrimInfo 1 (MLPccall(1, "sml_abs_real"))
  55. and makestringReal = mkPrimInfo 1 (MLPccall(1, "sml_string_of_float"))
  56. and addReal = mkPrimInfo 1 MLPadd_real
  57. and subReal = mkPrimInfo 1 MLPsub_real
  58. and mulReal = mkPrimInfo 1 MLPmul_real
  59. and ltReal = mkPrimInfo 1 MLPlt_real
  60. and gtReal = mkPrimInfo 1 MLPgt_real
  61. and leReal = mkPrimInfo 1 MLPle_real
  62. and geReal = mkPrimInfo 1 MLPge_real
  63. ;
  64.  
  65. fun resolveRealOvlId loc "~"    OVL1NNo  = negReal
  66.   | resolveRealOvlId loc "abs"  OVL1NNo  = absReal
  67.   | resolveRealOvlId loc "makestring" OVL1NSo = makestringReal
  68.   | resolveRealOvlId loc "+"    OVL2NNNo = addReal
  69.   | resolveRealOvlId loc "-"    OVL2NNNo = subReal
  70.   | resolveRealOvlId loc "*"    OVL2NNNo = mulReal
  71.   | resolveRealOvlId loc "<"    OVL2NNBo = ltReal
  72.   | resolveRealOvlId loc ">"    OVL2NNBo = gtReal
  73.   | resolveRealOvlId loc "<="   OVL2NNBo = leReal
  74.   | resolveRealOvlId loc ">="   OVL2NNBo = geReal
  75.   | resolveRealOvlId loc _ _ = fatalError "resolveRealOvlId"
  76. ;
  77.  
  78. val makestringString = mkPrimInfo 1 (MLPccall(1, "sml_makestring_of_string"))
  79. and ltString = mkPrimInfo 1 MLPlt_string
  80. and gtString = mkPrimInfo 1 MLPgt_string
  81. and leString = mkPrimInfo 1 MLPle_string
  82. and geString = mkPrimInfo 1 MLPge_string
  83. ;
  84.  
  85. fun resolveStringOvlId loc "makestring" OVL1NSo = makestringString
  86.   | resolveStringOvlId loc "<"    OVL2NNBo = ltString
  87.   | resolveStringOvlId loc ">"    OVL2NNBo = gtString
  88.   | resolveStringOvlId loc "<="   OVL2NNBo = leString
  89.   | resolveStringOvlId loc ">="   OVL2NNBo = geString
  90.   | resolveStringOvlId loc id     _ =
  91.       errorOverloadingType loc id type_string
  92. ;
  93.  
  94. fun resolveOvlId loc id ovltype tau =
  95.   case (id, ovltype) of
  96.       ("print", OVL1TXXo) =>
  97.         let val sc = freshSchemeOfType tau in
  98.           mkPrimInfo 1 (MLPgvt({qual="Meta", id="print"}, ref (Obj.repr sc)))
  99.         end
  100.     | ("installPP", OVL1TPUo) =>
  101.         let val sc = freshSchemeOfType tau in
  102.           mkPrimInfo 1 (MLPgvt({qual="Meta", id="installPP"}, ref (Obj.repr sc)))
  103.         end
  104.     | (_,_) =>
  105.         (case tyNameOfType tau of
  106.             SOME tyname =>
  107.               if (isEqTN tyname tyname_int) then
  108.                 resolveIntOvlId loc id ovltype
  109.               else if (isEqTN tyname tyname_char) then
  110.                 resolveCharOvlId loc id ovltype
  111.               else if (isEqTN tyname tyname_real) then
  112.                 resolveRealOvlId loc id ovltype
  113.               else if (isEqTN tyname tyname_string) then
  114.                 resolveStringOvlId loc id ovltype
  115.               else
  116.                 errorOverloadingType loc id tau
  117.           | NONE =>
  118.               errorMsg loc
  119.                 ("Unable to resolve overloaded identifier: " ^ id))
  120. ;
  121.  
  122. fun resolve3Dot (loc: Location) fs rho =
  123.   let val (fields, unresolved) = contentsOfRowType rho
  124.       val () =
  125.         if unresolved then
  126.           errorMsg loc "Unresolved record pattern"
  127.         else ();
  128.       val fs' = map (fn (lab,_) => (lab, (loc, WILDCARDpat))) fields
  129.   in fs @ fs' end
  130. ;
  131.  
  132. fun resolveOvlPat (loc, pat') =
  133.   case pat' of
  134.     SCONpat _ => ()
  135.   | VARpat _ => ()
  136.   | WILDCARDpat => ()
  137.   | NILpat _ => ()
  138.   | CONSpat(_, p) => resolveOvlPat p
  139.   | EXNILpat _ => ()
  140.   | EXCONSpat(_, p) => resolveOvlPat p
  141.   | EXNAMEpat _ => fatalError "resolveOvlPat"
  142.   | REFpat p => resolveOvlPat p
  143.   | RECpat rp =>
  144.       (case !rp of
  145.            RECrp(fs, NONE) =>
  146.              (app_field resolveOvlPat fs;
  147.               rp := TUPLErp(map snd (sortRow fs)))
  148.          | RECrp(fs, SOME rho) =>
  149.              (app_field resolveOvlPat fs;
  150.               rp := TUPLErp(map snd (sortRow (resolve3Dot loc fs rho))))
  151.          | TUPLErp _ => fatalError "resolveOvlPat")
  152.   | VECpat ps => app resolveOvlPat ps
  153.   | PARpat p => resolveOvlPat p
  154.   | INFIXpat _ => fatalError "resolveOvlPat"
  155.   | TYPEDpat(p,t) =>
  156.       resolveOvlPat p
  157.   | LAYEREDpat(p1, p2) =>
  158.       (resolveOvlPat p1; resolveOvlPat p2)
  159. ;
  160.  
  161. fun resolveOvlExp (loc, exp') =
  162.   case exp' of
  163.     SCONexp _ => ()
  164.   | VARexp(ref (RESve _)) => ()
  165.   | VARexp(ve as ref (OVLve (ii, ovltype, tau))) =>
  166.       let val {qualid, info} = ii
  167.           val {qual, id} = qualid
  168.           val pi = resolveOvlId loc id ovltype tau
  169.       in
  170.         #idKind info :=
  171.           { qualid={qual="General", id=id}, info=PRIMik pi };
  172.         ve := RESve ii
  173.       end
  174.   | FNexp mrules =>
  175.       app resolveOvlMRule mrules
  176.   | APPexp(e1, e2) =>
  177.       (resolveOvlExp e1; resolveOvlExp e2)
  178.   | LETexp(dec, body) =>
  179.       (resolveOvlDec dec; resolveOvlExp body)
  180.   | RECexp(r as ref (RECre fs)) =>
  181.       (app_field resolveOvlExp fs;
  182.        if isTupleRow fs then
  183.          r := TUPLEre(map snd fs)
  184.        else ())
  185.   | RECexp(ref (TUPLEre _)) => fatalError "resolveOvlExp"
  186.   | VECexp es =>
  187.       app resolveOvlExp es
  188.   | PARexp e =>
  189.       resolveOvlExp e
  190.   | INFIXexp es  => fatalError "resolveOvlExp"
  191.   | TYPEDexp(e,ty) =>
  192.       resolveOvlExp e
  193.   | ANDALSOexp(e1, e2) =>
  194.       (resolveOvlExp e1; resolveOvlExp e2)
  195.   | ORELSEexp(e1, e2) =>
  196.       (resolveOvlExp e1; resolveOvlExp e2)
  197.   | HANDLEexp(e, mrules) =>
  198.       (resolveOvlExp e; app resolveOvlMRule mrules)
  199.   | RAISEexp e =>
  200.       resolveOvlExp e
  201.   | IFexp(e0, e1, e2) =>
  202.       (resolveOvlExp e0; resolveOvlExp e1; resolveOvlExp e2)
  203.   | WHILEexp(e1, e2) =>
  204.       (resolveOvlExp e1; resolveOvlExp e2)
  205.   | SEQexp(e1, e2) =>
  206.       (resolveOvlExp e1; resolveOvlExp e2)
  207.  
  208. and resolveOvlMRule (MRule(pats, exp)) =
  209.   (app resolveOvlPat pats; resolveOvlExp exp)
  210.  
  211. and resolveOvlDec (_, dec') =
  212.   case dec' of
  213.     VALdec (pvbs, rvbs) =>
  214.       (app resolveOvlValBind pvbs; app resolveOvlValBind rvbs)
  215.   | PRIM_VALdec _ => ()
  216.   | FUNdec _ => fatalError "resolveOvlDec"
  217.   | TYPEdec _ => ()
  218.   | PRIM_TYPEdec _ => ()
  219.   | DATATYPEdec _ => ()
  220.   | ABSTYPEdec(_, _, dec2) =>
  221.       resolveOvlDec dec2
  222.   | EXCEPTIONdec _ => ()
  223.   | LOCALdec(dec1, dec2) =>
  224.       (resolveOvlDec dec1; resolveOvlDec dec2)
  225.   | OPENdec _ => ()
  226.   | EMPTYdec => ()
  227.   | SEQdec(dec1, dec2) =>
  228.       (resolveOvlDec dec1; resolveOvlDec dec2)
  229.   | FIXITYdec _ => ()
  230.  
  231. and resolveOvlValBind (ValBind(pat, exp)) =
  232.   (resolveOvlPat pat; resolveOvlExp exp)
  233. ;
  234.